Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/prolog/modprolg/mod-prol.lha/Prolog/modlib/src/$decompile.P

Text File | 1992-05-21 | 34.3 KB | 1,032 lines

/************************************************************************
*                                    *
* The SB-Prolog System                            *
* Copyright SUNY at Stony Brook, 1986; University of Arizona,1987    *
*                                    *
************************************************************************/

/*-----------------------------------------------------------------
SB-Prolog is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY.  No author or distributor
accepts responsibility to anyone for the consequences of using it
or for whether it serves any particular purpose or works at all,
unless he says so in writing.  Refer to the SB-Prolog General Public
License for full details.

Everyone is granted permission to copy, modify and redistribute
SB-Prolog, but only under the conditions described in the
SB-Prolog General Public License.   A copy of this license is
supposed to have been given to you along with SB-Prolog so you
can know your rights and responsibilities.  It should be in a
file named COPYING.  Among other things, the copyright notice
and this notice must be preserved on all copies.
------------------------------------------------------------------ */

/****************************************************************************
 *                                                                          *
 * This file has been changed by to include Modules Extensions              *
 * Changes by : Brian Paxton 1991/92                                        *
 * Last update : June 1992                                                  *
 *                                                                          *
 * Organisation : University of Edinburgh.                                  *
 * For : Departments of Computer Science and Artificial Intelligence        *
 *       Fourth Year Project.                                               *
 *                                                                          *
 ****************************************************************************/

/* This file contains predicates that traverse a buffer containing
   asserted code, and reconstruct the clause that was asserted.  This
   code is tied fairly tightly to the code generated by "assert", so
   changes to assert may require corresponding updates to this code.
   This also means that compiled code (i.e. that generated by "compile")
   cannot be decompiled.                    */

$decompile_export([$clause/2,$clause/3,$listing/1,$instance/2,
                   $oldlisting/0,$listing/0,$list_module/1]).

% $decompile_use : $bio $buff $bmeta $meta $assert $blist $deb $currsym

$clause(Hd,Body) :- $clause(Hd,Body,_,1).

$clause(Hd,Body,Ref) :- $clause(Hd,Body,Ref,1).

$clause(Hd,Body,Ref,Xform) :-
     nonvar(Hd),
     !,
     $decompile(Hd, Body, Ref, Xform).
$clause(Hd,Body,Ref,Xform) :-
     $is_buffer(Ref),    /* better be a DB ref! */
     $dec_getpsc(Ref,16,_,Psc),
     $mkstr(Psc,Hd0,Arity),
     !,
     $decompile_clause(Ref,Arity,Hd0,Body0),
     (Body0 ?= true ->
          (Hd = Hd0, Body = Body0) ;
      (arg(Arity,Hd0,CutArg),
       $dec_xform(Body0,CutArg,Body,Xform),
       RArity is Arity - 1,
       $functor(Hd0,Pred,_), $functor(Hd,Pred,RArity),
       $dec_copyargs(RArity,Hd0,Hd)
      )
     ).
$clause(Hd,B,R,_) :-
     $telling(X), $tell(stderr),
     $writename('*** Error: illegal argument(s) to clause/[2,3]: <'),
     $write(Hd), $write(', '), $write(B), $write(', '), $write(R), $write('> ***'), $nl,
     $told, $tell(X),
     fail.

% The old version of listing is still available here as $oldlisting/0

$oldlisting :-
     $predicate_property(X,interpreted),
     $functor(X,P,N),
     $listing(P/N),
     fail.
$oldlisting.

$listing(Pred) :- $listing(Pred,1).

$listing([],_) :- !.
$listing([H|L],Xform) :-
     !,
     ($listing(H,Xform) -> true ; true),   /* do the rest anyway */
     $listing(L,Xform).
$listing(Pred,Xform) :-
     nonvar(Pred) ->
          (Pred = P/N ->
           ($functor(Hd,P,N),
            ($decompile(Hd,Body,_,Xform),
             $portray_clause((Hd :- Body)),
             fail    /* backtrack to get all clauses */
            ) ;
            true
           ) ;
           ($errmsg('*** Error: argument to listing/1 must be of the form <pred>/<arity>'), $nl
           )
      ) ;
        ($errmsg('*** Error: argument to listing/1 must be instantiated ***'), fail).


$instance(Ref, Instance) :-
     $is_buffer(Ref) ->
          $instance_1(Ref, Instance) ;
      ($telling(X), $tell(stderr),
       $write('*** Error: argument 1 of instance/2 must be a DB reference ***'), $nl,
       $told, $tell(X),
       fail
      ).

$instance_1(Ref, Instance) :-
     $clause(H, B, Ref),
     (H = '_$record_db'(_, Instance) ->
          true ;
      Instance = (H :- B)
     ).

$dec_getbuffwd(Buff,Li,Lo,Word) :-
    Lo is Li+2, $buff_code(Buff,Li,6 /* gb */,Word).

$dec_getbuffnum(Buff,Li,Lo,Num) :-
    Lo is Li+4, $buff_code(Buff,Li,5 /* gn */,Num).

$dec_getbuffloat(Buff,Li,Lo,Num) :-
    Lo is Li+4, $buff_code(Buff,Li,29 /* gf */,Num).

$dec_getpsc(Buff,Li,Lo,Psc) :-
    Lo is Li+4, $buff_code(Buff,Li,28 /* gppsc */, Psc).

$decompile(Head, Body, Clref, Xform) :-
     $functor(Head,P,N),
     $symtype(Head, Type),
     (Type =\= 1 ->
          ($dec_errmsg(Type,P,N), fail) ;
      ($dec_GetPrref(Head,Prref),
           $buff_code(Prref,8,8 /* gpb */, FirstClref),
       $clause_addr(FirstClref, Clref,P,N),
       NArity is N + 1,    /* extra argument introduced during assert
                      to handle cuts */
           $functor(NHd,P,NArity),
       $dec_copyargs(N,Head,NHd),
       arg(NArity,NHd,CutArg),
       $decompile_clause(Clref, NArity, NHd, Body0),
       $dec_xform(Body0,CutArg,Body,Xform)
      )
     ).

$dec_GetPrref(Head,Prref) :-
     $assert_get_prref(Head, Prref0),
     $dec_getbuffwd(Prref0,4,_,Op),
     (Op =:= 91 /* jumptbreg */ ->  /* clause present, no interception */
          Prref = Prref0 ;
      (Op =:= 92 /* unexec */ ->  /* call intercept: trace/ET &c. */
           ($functor(Head,P,N), Pred = P/N,
            $dec_undo_inters(Pred,Inters),
        $dec_GetPrref(Head,Prref),
        $dec_do_inters(Inters,P,N)
           )
     )
     ).

$dec_undo_inters(Pred,Inters) :-   /* undo effects of call interception */
     (($symtype('_$traced_preds'(_),TType),
       TType > 0,
       '_$traced_preds'(Pred)
      ) ->
          (Inters = [trace|I0], $deb_unset(Pred)) ;
      Inters = I0
     ),
     (($symtype('_$spy_points'(_),SType),
       SType > 0,
       '_$spy_points'(Pred)
      ) ->
          (I0 = [spy|I1], $deb_unset(Pred)) ;
      I0 = I1
     ),
     (($symtype($deb_ugging(_),DType),
       DType > 0
      ) ->
           (I1 = [debugging(X)], $deb_ugging(X)) ;
       I1 = []
     ).

$dec_do_inters([],P,A).
$dec_do_inters([I|IRest],P,A) :-
     $dec_do_inters1(I,P,A), $dec_do_inters(IRest,P,A).

$dec_do_inters1(trace,P,A) :- $deb_set(P,A,$deb_trace(_)).
$dec_do_inters1(spy,  P,A) :- $deb_set(P,A,$deb_spy(_)).
$dec_do_inters1(debugging(X),_,_) :- X =:= 1 -> $debug ; $nodebug.

/* $clause_addr/4 takes the reference of the first clause for a predicate,
   and returns the reference of a clause for the predicate, backtracking
   successively through all of them.                    */

$clause_addr(CurrClref,Clref,P,N) :-
     $buff_code(CurrClref,4,6 /* gb */, Sop),
     ((Sop =:= 44 ; Sop =:= 85) ->     /* trustmeelsefail or noop */
          $clause_addr1(CurrClref,Clref,P,N) ;
      ((Sop =:= 42 ; Sop =:= 43) -> /* trymeelse or retrymeelse */
           ($buff_code(CurrClref,8,8 /* gpb */, NextClref),
            ($clause_addr1(CurrClref,Clref,P,N) ;
         $clause_addr(NextClref, Clref,P,N)  /* get next clause */
        )
           )
     )
     ).

$clause_addr1(CurrCl,Cl,P,N) :-
     $buff_code(CurrCl,20,6 /* gb */,55) ->    /* check if SOB-buffer */
         ($buff_code(CurrCl,36,8 /* gpb */,Clref),
      $clause_addr(Clref,Cl,P,N)
     ) ;
     ($buff_code(CurrCl,12,6 /* gb */,77 /* jump */) ->
          ($telling(X), $tell(stderr),
           $writename('*** Warning: '),
               $writename(P), $writename('/'), $writename(N),
               $writename(' contains compiled code that is not being decompiled ***'), $nl,
               $told, $tell(X),
           fail
          ) ;
          Cl = CurrCl
         ).

$decompile_clause(Clref, N, Head, Body) :-
     $buff_code(Clref,12,6 /* gb */, Op),
     $opcode(fail, FailOp),
     Op =\= FailOp, /* make sure the clause hasn't been erased */
     $dec_mk_rmap(4,4,Rmap0),
     $decompile_head(Clref,1,N,Head,20,Lm,Rmap0,Rmap1),
     $decompile_body(Clref,Body,Lm,Rmap1).

$decompile_head(Buff,Arg,Arity,Term,Li,Lo,Rmap0,Rmap1) :-
     Arg > Arity ->
          (Li = Lo, Rmap0 = Rmap1) ;
           ($dec_getbuffwd(Buff,Li,Lm0,Op),
       $dec_argreg(Op,Buff,Lm0,Reg),
       (Reg =:= Arg ->
            $dec_hdarg(Op,Buff,Term,Lm0,Lm1,Rmap0,Rmap2) ;
        ( Lm1 = Li, Rmap2 = Rmap0,
         $dec_map_lookup(Arg,Rmap0,X),
         arg(Arg,Term,X)
        )
       ),
       NextArg is Arg+1,
       $decompile_head(Buff,NextArg,Arity,Term,Lm1,Lo,Rmap2,Rmap1)
      ).

$dec_hdarg(3,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* gettval(R1,R2) */
    Li1 is Li+2,    /* skip pad word */
    $dec_getbuffwd(Buff,Li1,Lm1,Arg1),
    $dec_getbuffwd(Buff,Lm1,Lo,Arg2),
    arg(Arg1,Term,T), arg(Arg2,Term,T),
    $dec_map_lookup(Arg1,Rmap,T),
    $dec_map_lookup(Arg2,Rmap,T).
$dec_hdarg(4,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getcon(Con, N) */
    $dec_getbuffwd(Buff,Li,Lm,Arg),
    arg(Arg,Term,Const),
    $dec_getpsc(Buff,Lm,Lo,Const),
    $dec_map_lookup(Arg,Rmap,Const).
$dec_hdarg(5,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getnil(N) */
    $dec_getbuffwd(Buff,Li,Lo,Arg),
    arg(Arg,Term,[]),
    $dec_map_lookup(Arg,Rmap,[]).
$dec_hdarg(6,Buff,Term,Li,Lo,R0,R1) :-        /* getstr(Str,N) */
    $dec_getbuffwd(Buff,Li,Lm1,Arg),
    $dec_getpsc(Buff,Lm1,Lm2,Func),
    $mkstr(Func,Str,Arity),
    arg(Arg,Term,Str),
    $dec_subs(1,Arity,Buff,Str,Lm2,Lo,R0,R1),
    $dec_map_lookup(Arg,R1,Str).
$dec_hdarg(7,Buff,Term,Li,Lo,R0,R1) :-        /* getlist(N) */
    $dec_getbuffwd(Buff,Li,Lm1,Arg),
    List = [_|_], arg(Arg,Term,List),
    $dec_subs(1,2,Buff,List,Lm1,Lo,R0,R1),
    $dec_map_lookup(Arg,R1,List).
$dec_hdarg(14,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getnumcon(Num, N) */
    $dec_getbuffwd(Buff,Li,Lm,Arg),
    arg(Arg,Term,N),
    $dec_getbuffnum(Buff,Lm,Lo,N),
    $dec_map_lookup(Arg,Rmap,N).
$dec_hdarg(32,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getfloatcon(Num, N) */
    $dec_getbuffwd(Buff,Li,Lm,Arg),
    arg(Arg,Term,N),
    $dec_getbuffloat(Buff,Lm,Lo,N),
    $dec_map_lookup(Arg,Rmap,N).
$dec_hdarg(39,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getlist_tvar_tvar */
    $dec_getbuffwd(Buff,Li,Lm0,Arg),
    $dec_getbuffwd(Buff,Lm0,Lm1,R1),
    $dec_getbuffwd(Buff,Lm1,Lo,R2),
    $dec_map_lookup(R1,Rmap,A1),
    $dec_map_lookup(R2,Rmap,A2),
    Sub = [A1|A2], arg(Arg,Term,Sub),
    $dec_map_lookup(Arg,Rmap,Sub).
$dec_hdarg(40,Buff,Term,Li,Lo,R0,R1) :-        /* getcomma(N) */
    $dec_getbuffwd(Buff,Li,Lm1,Arg),
    Sub = ','(_,_), arg(Arg,Term,Sub),
    $dec_subs(1,2,Buff,Sub,Lm1,Lo,R0,R1),
    $dec_map_lookup(Arg,R1,Sub).
$dec_hdarg(41,Buff,Term,Li,Lo,Rmap,Rmap) :-    /* getcomma_tvar_tvar */
    $dec_getbuffwd(Buff,Li,Lm0,Arg),
    $dec_getbuffwd(Buff,Lm0,Lm1,R1),
    $dec_getbuffwd(Buff,Lm1,Lo,R2),
    $dec_map_lookup(R1,Rmap,A1),
    $dec_map_lookup(R2,Rmap,A2),
    Sub = ','(A1,A2), arg(Arg,Term,Sub),
    $dec_map_lookup(Arg,Rmap,Sub).

/* $dec_argreg/3 returns the "main" register number for an instruction in
   a buffer.  Argument 1 is the opcode of the "current" instruction. */

$dec_argreg(3,Buff,Disp,N) :-            /* gettval(R,N) */
     Lr is Disp + 4,        /* skip pad byte, op1 */
     $buff_code(Buff,Lr,6 /* gb */, N).
$dec_argreg(Op,Buff,Disp,N) :-
     Op >= 4, Op =< 7, /* getcon(C,N)|getnil(N)|getstr(Str,N)|getlist(N) */
     $buff_code(Buff,Disp,6 /* gb */, N).
$dec_argreg(14,Buff,Disp,N) :-            /* getnumcon(Num,N) */
     $buff_code(Buff,Disp,6 /* gb */, N).
$dec_argreg(32,Buff,Disp,N) :-            /* getfloatcon(Num,N) */
     $buff_code(Buff,Disp,6 /* gb */, N).
$dec_argreg(Op,Buff,Disp,N) :-
     Op >= 39, /* getlist_tvar_tvar(N,_,_) | getcomma(N) | */
     Op =< 41, /* getcomma_tvar_tvar(N,_,_) */
     $buff_code(Buff,Disp,6 /* gb */, N).

/*  if we hit a "put" instruction we know we're past the head, so return an
    "impossible" register number.                    */
$dec_argreg(15,Buff,Disp,-1).        /* putnumcon(Num,N) */
$dec_argreg(18,Buff,Disp,-1).        /* puttvar(T,R) */
$dec_argreg(20,Buff,Disp,-1).        /* putcon(C,R) */
$dec_argreg(21,Buff,Disp,-1).        /* putnil(R) */
$dec_argreg(22,Buff,Disp,-1).        /* putstr(S,R) */
$dec_argreg(23,Buff,Disp,-1).        /* putlist(R) */
$dec_argreg(33,Buff,Disp,-1).        /* putfloatcon(Num,N) */
$dec_argreg(58,Buff,Disp,-1).        /* movreg(T,R) */
$dec_argreg(74,Buff,Disp,-1).        /* proceed */
$dec_argreg(75,Buff,Disp,-1).        /* execute(P) */

$dec_subs(N,Arity,Buff,Term,Li,Lo,Rin,Rout) :-
    N > Arity ->
        (Li = Lo, Rin = Rout) ;
    ($dec_getbuffwd(Buff,Li,Lm1,Op),
     $dec_sub(Op,Buff,Sub,Lm1,Lm2,Rin,Rmid),
     arg(N,Term,Sub),
     N1 is N+1,
     $dec_subs(N1,Arity,Buff,Term,Lm2,Lo,Rmid,Rout)
    ).

$dec_sub(10,Buff,X,Li,Lo,Rmap,Rmap) :-        /* unitvar(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_lookup(R,Rmap,X).
$dec_sub(11,Buff,X,Li,Lo,Rmap,Rmap) :-        /* unitval(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_lookup(R,Rmap,X).
$dec_sub(12,Buff,Con,Li,Lo,Rmap,Rmap) :-    /* unicon(Con) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getpsc(Buff,Lm,Lo,Con).
$dec_sub(13,Buff,[],Li,Lo,Rmap,Rmap) :-        /* uninil */
    Lo is Li + 2.
$dec_sub(26,Buff,X,Li,Lo,Rin,Rout) :-        /* bldtvar(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_update(R,Rin,X,Rout).
$dec_sub(27,Buff,X,Li,Lo,Rmap,Rmap) :-        /* bldtval(R) */
    $dec_getbuffwd(Buff,Li,Lo,R),
    $dec_map_lookup(R,Rmap,X).
$dec_sub(28,Buff,Con,Li,Lo,Rmap,Rmap) :-    /* bldcon(Con) */
    Lm is Li+2,    /* skip pad byte */
    $dec_getpsc(Buff,Lm,Lo,Con).
$dec_sub(29,Buff,[],Li,Lo,Rmap,Rmap) :-        /* bldnil */
    Lo is Li + 2.
$dec_sub(30,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* uninumcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffnum(Buff,Lm,Lo,Num).
$dec_sub(31,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* bldnumcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffnum(Buff,Lm,Lo,Num).
$dec_sub(34,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* unifloatcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffloat(Buff,Lm,Lo,Num).
$dec_sub(35,Buff,Num,Li,Lo,Rmap,Rmap) :-    /* bldfloatcon(Num) */
    Lm is Li+2,    /* skip pad bytes */
    $dec_getbuffloat(Buff,Lm,Lo,Num).


$decompile_body(Buff,Body,Loc,Rmap) :-
     $dec_getbuffwd(Buff,Loc,Lm0,Op),
     (Op =:= 74 ->                /* proceed */
          Body = true ;
      (Op =:= 75 ->            /* execute(P) */
           (Lm1 is Lm0 + 2,    /* skip pad bytes */
            $dec_getpsc(Buff,Lm1,_,Psc),
        $mkstr(Psc,Body,Arity),
        $dec_procputs(Arity,Rmap,Body)
           ) ;
           ($dec_bodyinst(Op,Buff,Lm0,Lm1,Rmap,Rmap0),
            $decompile_body(Buff,Body,Lm1,Rmap0)
           )
      )
     ).

$dec_bodyinst(3,Buff,Li,Lo,Rmap,Rmap) :-    /* gettval(R1,R2) */
     Li1 is Li+2,    /* skip pad bytes */
     $dec_getbuffwd(Buff,Li1,Lm1,Arg1),
     $dec_getbuffwd(Buff,Lm1,Lo,Arg2),
     $dec_map_lookup(Arg1,Rmap,T),
     $dec_map_lookup(Arg2,Rmap,T).
$dec_bodyinst(4,Buff,Li,Lo,Rmap,Rmap) :-    /* getcon(Con, N) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_getpsc(Buff,Lm,Lo,Const),
     $dec_map_lookup(R,Rmap,Const).
$dec_bodyinst(5,Buff,Li,Lo,Rmap,Rmap) :-    /* getnil(N) */
     $dec_getbuffwd(Buff,Li,Lo,R),
     $dec_map_lookup(R,Rmap,[]).
$dec_bodyinst(6,Buff,Li,Lo,Rin,Rout) :-        /* getstr(Str,N) */
     $dec_getbuffwd(Buff,Li,Lm1,R),
     $dec_getpsc(Buff,Lm1,Lm2,Func),
     $mkstr(Func,Str,Arity),
     $dec_map_lookup(R,Rin,Str),
     $dec_subs(1,Arity,Buff,Str,Lm2,Lo,Rin,Rout).
$dec_bodyinst(7,Buff,Li,Lo,Rin,Rout) :-        /* getlist(N) */
     $dec_getbuffwd(Buff,Li,Lm1,R),
     List = [_|_],
     $dec_map_lookup(R,Rin,List),
     $dec_subs(1,2,Buff,List,Lm1,Lo,Rin,Rout).
$dec_bodyinst(14,Buff,Li,Lo,Rmap,Rmap) :-    /* getnumcon(Num, N) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_getbuffnum(Buff,Lm,Lo,N),
     $dec_map_lookup(R,Rmap,N).
$dec_bodyinst(15,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm,R),        /* putnumcon(Num,R) */
     $dec_getbuffnum(Buff,Lm,Lo,Num),
     $dec_map_update(R,Rin,Num,Rout).
$dec_bodyinst(18,Buff,Li,Lo,Rin,Rout) :-    /* puttvar(R1, R2) */
     Li1 is Li + 2,
     $dec_getbuffwd(Buff,Li1,Lm,R1),
     $dec_getbuffwd(Buff,Lm,Lo,R2),
     $dec_map_update(R1,Rin,X,Rmid),
     $dec_map_update(R2,Rmid,X,Rout).
$dec_bodyinst(20,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm,R),        /* putcon(Con,R) */
     $dec_getpsc(Buff,Lm,Lo,Con),
     $dec_map_update(R,Rin,Con,Rout).
$dec_bodyinst(21,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lo,R),        /* putnil(R) */
     $dec_map_update(R,Rin,[],Rout).
$dec_bodyinst(22,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm0,R),        /* putstr(Str,R) */
     $dec_getpsc(Buff,Lm0,Lm1,Psc),
     $mkstr(Psc,Str,Arity),
     $dec_subs(1,Arity,Buff,Str,Lm1,Lo,Rin,Rmid),
     $dec_map_update(R,Rmid,Str,Rout).
$dec_bodyinst(23,Buff,Li,Lo,Rin,Rout) :-
     List = [_|_],                /* putlist(R) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_map_update(R,Rin,List,Rmid),
     $dec_subs(1,2,Buff,List,Lm,Lo,Rmid,Rout).
$dec_bodyinst(32,Buff,Li,Lo,Rmap,Rmap) :-    /* getfloatcon(Num, N) */
     $dec_getbuffwd(Buff,Li,Lm,R),
     $dec_getbuffloat(Buff,Lm,Lo,N),
     $dec_map_lookup(R,Rmap,N).
$dec_bodyinst(33,Buff,Li,Lo,Rin,Rout) :-
     $dec_getbuffwd(Buff,Li,Lm,R),        /* putfloatcon(Num,R) */
     $dec_getbuffloat(Buff,Lm,Lo,Num),
     $dec_map_update(R,Rin,Num,Rout).
$dec_bodyinst(39,Buff,Li,Lo,Rmap,Rmap) :-    /* getlist_tvar_tvar */
     $dec_getbuffwd(Buff,Li,Lm0,R0),
     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
     $dec_getbuffwd(Buff,Lm1,Lo,R2),
     $dec_map_lookup(R1,Rmap,A1),
     $dec_map_lookup(R2,Rmap,A2),
     $dec_map_lookup(R0,Rmap,[A1|A2]).
$dec_bodyinst(40,Buff,Li,Lo,Rin,Rout) :-    /* getcomma(N) */
     $dec_getbuffwd(Buff,Li,Lm1,R),
     Sub = ','(_,_), $dec_map_lookup(R,Rin,Sub),
     $dec_subs(1,2,Buff,Sub,Lm1,Lo,Rin,Rout).
$dec_bodyinst(41,Buff,Li,Lo,Rmap,Rmap) :-    /* getcomma_tvar_tvar */
     $dec_getbuffwd(Buff,Li,Lm0,R0),
     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
     $dec_getbuffwd(Buff,Lm1,Lo,R2),
     $dec_map_lookup(R1,Rmap,A1),
     $dec_map_lookup(R2,Rmap,A2),
     $dec_map_lookup(R0,Rmap,','(A1,A2)).
$dec_bodyinst(58,Buff,Li,Lo,Rin,Rout) :-      /* movreg(R1,R2) */
     Lm0 is Li + 2,    /* skip pad bytes */
     $dec_getbuffwd(Buff,Lm0,Lm1,R1),
     $dec_getbuffwd(Buff,Lm1,Lo,R2),
     $dec_map_lookup(R1,Rin,Val),
     $dec_map_update(R2,Rin,Val,Rout).

$dec_procputs(Arg,Rmap,Body) :-
     Arg =:= 0 ->
          true ;
      ($dec_map_lookup(Arg,Rmap,Val),
       arg(Arg,Body,Val),
       Next is Arg - 1,
       $dec_procputs(Next,Rmap,Body)
      ).

$dec_xform(Body0,C,Body1,N) :-
     N > 0 -> $dec_xform_1(Body0,C,Body1) ; Body0 = Body1.

$dec_xform_1(','(A0,A1,A2,A3),C,(B0,B1,B2,B3)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1),
     $dec_xform_1(A2,C,B2),
     $dec_xform_1(A3,C,B3).
$dec_xform_1(','(A0,A1),C,','(B0,B1)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1).
$dec_xform_1(';'(A0,A1),C,';'(B0,B1)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1).
$dec_xform_1('->'(A0,A1),C,'->'(B0,B1)) :-
     !,
     $dec_xform_1(A0,C,B0),
     $dec_xform_1(A1,C,B1).
$dec_xform_1('_$cutto'(V),C,Lit) :-
     !,
     (C == V -> Lit = '!' ; Lit = '_$cutto'(V)).
$dec_xform_1(L,_,L).


$dec_errmsg(Type,P,N) :-
     $telling(X), $tell(stderr),
     $writename('*** Warning: '),
     $writename(P), $writename('/'), $writename(N),
     $dec_errmsg1(Type, ErrType),
     $writename(ErrType), $writename(', cannot decompile ***'), $nl,
     $told, $tell(X).

$dec_errmsg1(0, ' is undefined').
$dec_errmsg1(2, ' is compiled').

/*  The following predicates manipulate a "register map", which is
    basically an array of 256 elements represented as a complete quadtree
    of height 4.                            */

$dec_mk_rmap(Level,Arity,Map) :-
     $functor(Map,rm,Arity),
     (Level =:= 1 ->
         true ;
     (Lev1 is Level - 1,
      $dec_mk_rmaps(Arity,Arity,Lev1,Map)
     )
     ).

$dec_mk_rmaps(Argno,Arity,Level,Map) :-
     Argno =:= 0 ->
         true ;
     (arg(Argno,Map,SubMap),
      $dec_mk_rmap(Level,Arity,SubMap),
      NextArg is Argno - 1,
      $dec_mk_rmaps(NextArg,Arity,Level,Map)
     ).

$dec_map_lookup(I,Tree,Val) :-
     Index is I - 1,
     $dec_map_lookup(4,Index,Tree,Val).

$dec_map_lookup(Level,Index,Tree,Val) :-
    $get_currindex(Level,Index,CurrInd),
    (Level =:= 1 ->
         arg(CurrInd,Tree,Val) ;
     (arg(CurrInd,Tree,SubTree),
      NewLevel is Level - 1,
      $dec_map_lookup(NewLevel,Index,SubTree,Val)
     )
    ).

$dec_map_update(I,Tree,Val,NTree) :-
     Index is I-1,
     $dec_map_update(4,Index,Tree,Val,NTree).

$dec_map_update(Level,Index,Tree,Val,NTree) :-
    NTree = rm(_,_,_,_),
    $get_currindex(Level,Index,CurrInd),
    (Level =:= 1 ->
     $subst_arg(4,CurrInd,Tree,Val,NTree) ;
     (arg(CurrInd,Tree,SubTree),
      NewLevel is Level - 1,
      $dec_map_update(NewLevel,Index,SubTree,Val,NSubTree),
      $subst_arg(4,CurrInd,Tree,NSubTree,NTree)
     )
     ).

$subst_arg(N,I,Tree,Val,NTree) :-
     N =:= 0 ->                /* done! */
          true ;
      ((N =:= I ->            /* make the change */
           arg(N,NTree,Val) ;
           (arg(N,Tree,Arg), arg(N,NTree,Arg))
           ),
       N1 is N - 1,
       $subst_arg(N1,I,Tree,Val,NTree)
      ).

$get_currindex(Level,Index,N) :-
    Shift is (Level-1) << 1,  /* Shift = 2*(Level-1) */
    Mask is 2'11 << Shift,
    N is ((Index /\ Mask) >> Shift) + 1.

$dec_copyargs(N,T1,T2) :-
     N =:= 0 ->
          true ;
      (arg(N,T1,X), arg(N,T2,X),
       N1 is N - 1,
       $dec_copyargs(N1,T1,T2)
      ).

% The new version of listing/0 which lists all signatures, structures and
% functors defined at the top level.

$listing :-
    $setof(X, D0^D1^D2^D3^$module_signature(X,D0,D1,D2,D3),
           Sigs),
    $list_signatures(Sigs),
    $setof(X, D0^D1^D2^D3^$module_structure(X,D0,D1,D2,D3),
           Strnames),
    $grab_structure_tags(Strnames, Strs),
    $grab_predicates(Strnames,Strs,Preds),
    $list_structures(Preds),
    $setof(X, D0^D1^D2^D3^D4^D5^D6^D7^D8^
                  $module_functor(X,D0,D1,D2,D3,D4,D5,D6,D7,D8),
          Funs),
    $list_functors(Funs).

$listing.

% $list_module/1 lists the module corresponding to the argument tag. Can list
% any structure, including sub-structures not listed by listing/0.

$list_module(Tag) :-
    $isa_structuretag(Tag),
    $get_structure(Tag,Name,Substrs,Preds,Funs),
    $grab_predicates([Name],[Tag],[str(_,_,Actualpreds)]),
    $writename('structure '),
    $write(Name),
    $writename(' ='), $nl,
    $writename('  struct'), $nl,
    $list_struct(Substrs,Preds,Funs),
    $list_mapped_functions(Tag),
    $list_preds(Actualpreds,Tag),
    $writename('  end.'), $nl.

% List all signatures.

$list_signatures(List) :-
    List == [] -> true ;
        ( List = [Name|Rest],
          $module_signature(Name,_,Substrs,Preds,Funs), !,
          $writename('signature '),
          $writename(Name),
          $writename(' ='), $nl,
          $writename('  sig'), $nl,
          $list_struct(Substrs,Preds,Funs),
          $writename('  end.'), $nl,
          $list_signatures(Rest) ).

% List all structures.
% Note that in general the list of predicates given in the structure signature,
% is not an exhaustive list of the predicates actually in the structure.

$list_structures(List) :-
    List == [] -> true ;
        ( List = [str(Name,Tag,Actualpreds)|Rest],
          $module_structure(Name,Tag,Substrs,Preds,Funs), !,
          $writename('structure '),
          $writename(Name),
          $writename(' ='), $nl,
          $writename('  struct'), $nl,
          $list_struct(Substrs,Preds,Funs),
          $list_mapped_functions(Tag),
          $list_preds(Actualpreds,Tag),
          $writename('  end.'), $nl,
          $list_structures(Rest) ).

% List all functors.

$list_functors(List) :-
    List == [] -> true ;
        ( List = [Name|Rest],
          $module_functor(Name,_,Params,_,_,_,Strexpr,_,_,_), !,
          $writename('functor '),
          $univ(Functor,[Name|Params]),
          $write(Functor),
          $writename(' ='), $nl,
          $writename('  struct'), $nl,
          ( Strexpr = Code/_ -> $list_functor_code(Code) ;
                            $list_functor_code(Strexpr) ),
          $writename('  end.'), $nl,
          $list_functors(Rest) ).

% List the contents of a signature, displaying any references to sub-structures
% as '...'.

$list_struct(Substrs,Preds,Funs) :-
    $remove_sub_items(Substrs, Substrs0, $flag),
    $remove_sub_items(Preds, Preds0, $flag),
    $remove_sub_items(Funs, Funs0, $flag),
    ( Substrs0 == [] -> true ;
               ( $writename('    structure '),
                 $list_list(Substrs0) ) ),
    ( Preds0 == [] -> true ;
             ( $writename('    pred '),
               $list_list(Preds0) ) ),
    ( Funs0 == [] -> true ;
            ( $writename('    fun '),
              $list_list(Funs0) ) ).

$remove_sub_items([], [], $flag).
$remove_sub_items([], ['...'], $flagset).
$remove_sub_items([_ : _ / _ ---> _|Rest], Result, _) :- !,
    $remove_sub_items(Rest, Result, $flagset).
$remove_sub_items([_ : _ ---> _|Rest], Result, _) :- !,
    $remove_sub_items(Rest, Result, $flagset).
$remove_sub_items([Item|Rest], [Item|Result], Flag) :-
    $remove_sub_items(Rest, Result, Flag).

$list_list(['...']) :- !,
    $writename('... .'),$nl.
$list_list([Name ---> _]) :- !,
    $write(Name),$writename('.'),$nl.
$list_list([Name ---> _|Tail]) :-
    $write(Name),
    $writename(' and '),
    $list_list(Tail).

% List any 'fun X = Y' functions declared in the current structure.

$list_mapped_functions(Tag) :-
    $symtype($mapped_function(_,_,_,_), Type),
    Type > 0,
    $mapped_function(X,Arity,Y,Tag),
    $dismantle_name(X,X0,_),
    $dismantle_name(Y,Y0,_),
    $writename('    fun '),
    $write(X0/Arity = Y0),
    $writename('.'), $nl, fail.
$list_mapped_functions(_).

% List the clauses given in a functor body.

$list_functor_code(List) :-
    List == [] -> true ;
        ( List = [Clause|Rest],
          not(not($list_portray_clause(Clause,perv))),
          $list_functor_code(Rest) ).

% Given a list of tags (corresponding to top level structures only), find
% their names.

$grab_structure_tags([], []).
$grab_structure_tags([Name|Names], [Tag|Tags]) :-
    $module_structure(Name, Tag, S, P, F), !,
    $grab_structure_tags(Names, Tags).

% The naive way of listing to contents of a structure is to call
% current_predicate/2, checking each returned predicate name for membership in
% the current structure (by comparing tags), displaying it if necessary, and
% completing when current_predicate/2 eventually fails.
% However, the database is massive (as it includes the system predicates too)
% and so we gather together all the predicates only once (here), and increase
% efficiency enormously.
% The predicate actually returns a list of the following :
%           str(Name, Tag, List)
% where Name is the name of the structure whose tag is Tag, and which contains
% the predicates given in List.

$grab_predicates(Names, List,Result) :-
    bagof(pred(Tag,Term), Name^Term^Tag^Dummy^
                     ( $current_predicate(Name,Term),
                   $dismantle_name(Name,Dummy,Tag),
               $memberchk(Tag, List) ), Preds),
    $grab_predicates(Names, List, Preds, Result), !.

$grab_predicates([],[],_,[]).
$grab_predicates([Name|Names],[Tag|Tags],Preds,
             [str(Name,Tag,List)|Rest]) :-
    $grab_predicates(Tag, Preds, Newpreds, List),
    $grab_predicates(Names, Tags, Newpreds, Rest).

$grab_predicates(_,[],[],[]).
$grab_predicates(Tag,[pred(Tag,Term)|Preds],Newpreds,[Term|Rest]) :-
    $grab_predicates(Tag,Preds,Newpreds,Rest).
$grab_predicates(Tag,[Pred|Preds],[Pred|Newpreds],Rest) :-
    $grab_predicates(Tag,Preds,Newpreds,Rest).

% List the clauses in a structure, given a list of predicate names.

$list_preds([],_).
$list_preds([Term|Tail],Tag) :-
    $decompile(Term,Body,_,1),
    not(not($list_portray_clause((Term :- Body),Tag))),
    fail.
$list_preds([_|Tail],Tag) :-
    $list_preds(Tail,Tag).

% All clause printing for the module listing/0 is passed to this version
% of portray_clause. This is because we need each clause indented by a few
% spaces to the output looks reasonable.
% The code is almost a direct copy of that in $portray.P, which only a few
% minor changes.
% Similarly, the code for write has been copied here and named list_write/1,
% so that we can get it to stop printing the path of an item that belongs
% in the module we are printing.

$list_portray_clause((H :- B),Tag) :-
    $list_portray_namevars((H :- B), 0,_),
        !,
        $writename('    '),
        $list_write(H,Tag),
        (B ?= true ->
             true ;
             ($writename(' :- '), $nl,
              $list_portray_body(B,8,8,Tag))),
        $writename('.'),
        $nl.
$list_portray_clause(Fact,Tag) :-
    $list_portray_namevars(Fact,0,_),
        $writename('    '),
        $list_write(Fact,Tag),
        $writename('.'),
        $nl.

$list_portray_namevars(X,N,N1) :-
        var(X), !,
        $name(N,Nname),
        $append("V",Nname,XName),
        $name(X,XName),
        N1 is N + 1.
$list_portray_namevars(A,N,N) :- atomic(A), !.
$list_portray_namevars(Str,N,N1) :-
        $arity(Str,Arity),
        $list_portray_namevars_str(1,Arity,Str,N,N1).

$list_portray_namevars_str(Arg,Arity,Str,N0,N1) :-
        Arg > Arity ->
             N1 = N0 ;
             (arg(Arg,Str,Sub),
              $list_portray_namevars(Sub,N0,N2),
              NextArg is Arg + 1,
              $list_portray_namevars_str(NextArg,Arity,Str,N2,N1)
             ).

$list_portray_body(','(G1,G2),LT,RT,Tag) :-
    !,
    ($list_portray_CompoundGoal(G1) ->
         ($tab(LT), $writename('('), T1 = 0) ;
         T1 = LT),
    $list_portray_body(G1,T1,RT,Tag),
    ($list_portray_CompoundGoal(G1) ->
         ($nl,$tab(LT), $writename(')')) ;
         true),
    $writename(','), $nl,
    (($list_portray_CompoundGoal(G2), G2 \= ','(_,_)) ->
         Parens = 1 ; Parens = 0),
    (Parens =:= 1 ->
         ($tab(LT), $writename('('), T2 = 0) ;
         T2 = RT),
    $list_portray_body(G2,T2,RT,Tag),
    (Parens =:= 1 ->
         ($nl,$tab(LT), $writename(')')) ;
         true).
$list_portray_body(';'('->'(If,Then),Else),LT,RT,Tag) :-
    !,
    ($list_portray_CompoundGoal(If) ->
         ($tab(LT), $writename('('),
          $list_portray_conj(If,Tag),
          $writename(')')
         ) ;
         $list_portray_body(If,LT,RT,Tag)),
    $writename(' ->'), $nl,
    T1 is RT + 4,
    $list_portray_body(';'(Then,Else),T1,T1,Tag).
$list_portray_body(';'(G1,G2),LT,RT,Tag) :-
    !,
    ($list_portray_CompoundGoal(G1) ->
         ($tab(LT), $writename('('), T1 = 0) ;
         T1 = LT),
    $list_portray_body(G1,T1,RT,Tag),
    ($list_portray_CompoundGoal(G1) ->
         ($nl,$tab(LT), $writename(')')) ;
         true),
    $writename(' ;'), $nl,
    (($list_portray_CompoundGoal(G2), G2 \= ';'(_,_)) ->
          Parens = 1 ; Parens = 0),
    (Parens =:= 1 ->
         ($tab(LT), $writename('('), $nl, T2 is LT + 1) ;
         T2 = LT),
    $list_portray_body(G2,T2,RT,Tag),
    (Parens =:= 1 ->
         ($nl,$tab(LT), $writename(')')) ;
         true).
$list_portray_body(C,T,_,Tag) :-
    $tab(T),
    $list_write(C,Tag).

$list_portray_conj(','(C1,C2),Tag) :-
     !,
     $list_portray_conj(C1,Tag),
     $writename(', '),
     $list_portray_conj(C2,Tag).
$list_portray_conj(';'('->'(If,Then),Else),Tag) :-
     !,
     $writenam('( '),
     $list_portray_conj(If,Tag), $writename(' -> '),
     $list_portray_conj(Then,Tag), $writename(' ; '),
     $list_portray_conj(Else,Tag), $writename(' )').
$list_portray_conj(';'(C1,C2),Tag) :-
     !,
     $writename('( '),
     $list_portray_conj(C1,Tag), $writename(' ;'),
     $list_portray_conj(C2,Tag), $writename(' )').
$list_portray_conj('->'(C1,C2),Tag) :-
     !,
     $writename('( '),
     $list_portray_conj(C1,Tag), $writename(' -> '),
     $list_portray_conj(C2,Tag), $writename(' )').
$list_portray_conj(Lit,Tag) :- $list_write(Lit,Tag).

$list_portray_CompoundGoal(','(_,_)).
$list_portray_CompoundGoal(';'(_,_)).
$list_portray_CompoundGoal('->'(_,_)).

$list_write(T,Tag) :- $list_write(T,999,Tag).

$list_write(T,_,Tag) :- var(T), !,
    $list_writename(T,Tag).
$list_write([],_,Tag) :- !,
    $list_writename([],Tag).
$list_write([X|Y],_,Tag) :- !,
    $put(0'[), $list_write(X,999,Tag), $list_writetail(Y,Tag).
$list_write(T,Prec,Tag) :- $structure(T), !,
  $functor0(T, P), $arity(T, N),
  (N=:=1 ->
    ($read_curr_op(Opprec,fx,P) ->
        Nprec is Opprec-1,$list_writepreop(P,T,Prec,Opprec,Nprec,Tag);
     $read_curr_op(Opprec,fy,P) ->
        $list_writepreop(P,T,Prec,Opprec,Opprec,Tag);
     $read_curr_op(Opprec,xf,P) ->
        Nprec is Opprec-1,$list_writepostop(P,T,Prec,Opprec,Nprec,Tag);
     $read_curr_op(Opprec,yf,P) ->
        $list_writepostop(P,T,Prec,Opprec,Opprec,Tag);
        $list_writestr(P,N,T,Tag)
    );
  N=:=2 ->
   ($read_curr_op(Opprec,xfx,P) ->
       Nprec is Opprec-1,$list_writebinop(P,T,Prec,Opprec,Nprec,Nprec,Tag);
    $read_curr_op(Opprec,xfy,P) ->
       Nprec is Opprec-1,$list_writebinop(P,T,Prec,Opprec,Nprec,Opprec,Tag);
    $read_curr_op(Opprec,yfx,P) ->
       Nprec is Opprec-1,$list_writebinop(P,T,Prec,Opprec,Opprec,Nprec,Tag);
       $list_writestr(P,N,T,Tag)
   );
  $list_writestr(P,N,T,Tag)
  ).

$list_write(T,_,Tag) :- $list_writename(T,Tag).

$list_writestr(P,N,T,Tag) :-
        $list_writename(P,Tag), $put(0'(), arg(1, T, X), $list_write(X,999,Tag),
        $list_writearg(T, N, 1,Tag), $put(0')).

$list_writebinop(Op,Term,Oldp,Curp,Newlp,Newrp,Tag) :-
        arg(1,Term,Arg1),
        arg(2,Term,Arg2),
        (Curp > Oldp ->
                $put(0'(),
                $list_write(Arg1,Newlp),$tab(1),$list_writename(Op,Tag),
                $tab(1),$list_write(Arg2,Newrp,Tag),
                $put(0'))
              ;
                $list_write(Arg1,Newlp,Tag),$tab(1),$list_writename(Op,Tag),
                $tab(1),$list_write(Arg2,Newrp,Tag)
        ).


$list_writepreop(Op,Term,Oldp,Curp,Newp,Tag) :-
        arg(1,Term,Arg),
        (Curp > Oldp ->
                $put(0'(),
                $list_writename(Op,Tag),$tab(1),$list_write(Arg,Newp,Tag),
                $put(0'))
              ;
                $list_writename(Op,Tag),$tab(1),$list_write(Arg,Newp,Tag)
        ).

$list_writepostop(Op,Term,Oldp,Curp,Newp,Tag) :-
        arg(1,Term,Arg),
        (Curp > Oldp ->
                $put(0'(),
                $list_write(Arg,Newp,Tag),$tab(1),$list_writename(Op,Tag),
                $put(0'))
              ;
                $list_write(Arg,Newp,Tag),$tab(1),$list_writename(Op,Tag)
        ).

$list_writearg(T, N, N,Tag) :- !.
$list_writearg(T, N, M,Tag) :-
    L is M + 1, $put(0',), arg(L, T, X),
        $list_write(X,999,Tag), $list_writearg(T, N, L,Tag).

$list_writetail(X,Tag) :- var(X), ! ,
    $put(0'|), $list_writename(X,Tag), $put(0']).
$list_writetail([X|Y],Tag) :- !,
    $put(0',), $list_write(X,999,Tag), $list_writetail(Y,Tag).
$list_writetail([],Tag) :- !,
    $put(0']).
$list_writetail(X,Tag) :-
    $put(0'|), $list_write(X,999,Tag), $put(0']).

$list_writename(Name,Tag) :-
    $dismantle_name(Name,Newname,Tag) ->
                $writename(Newname) ;
            $write(Name).

/* ----------------------------- $decompile.P ----------------------------- */